home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / harvest.cpt / Harvest C / Tcl 6.2 / tclVar.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-04-12  |  62.5 KB  |  2,278 lines
  1. /* 
  2.  * tclVar.c --
  3.  *
  4.  *    This file contains routines that implement Tcl variables
  5.  *    (both scalars and arrays).
  6.  *
  7.  *    The implementation of arrays is modelled after an initial
  8.  *    implementation by Karl Lehenbauer, Mark Diekhans and
  9.  *    Peter da Silva.
  10.  *
  11.  * Copyright 1987-1991 Regents of the University of California
  12.  * Permission to use, copy, modify, and distribute this
  13.  * software and its documentation for any purpose and without
  14.  * fee is hereby granted, provided that the above copyright
  15.  * notice appear in all copies.  The University of California
  16.  * makes no representations about the suitability of this
  17.  * software for any purpose.  It is provided "as is" without
  18.  * express or implied warranty.
  19.  */
  20.  
  21. #ifndef lint
  22. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclVar.c,v 1.25 91/10/31 16:41:46 ouster Exp $ SPRITE (Berkeley)";
  23. #endif
  24.  
  25. #include "tclInt.h"
  26.  
  27. /*
  28.  * The strings below are used to indicate what went wrong when a
  29.  * variable access is denied.
  30.  */
  31.  
  32. static char *noSuchVar =    "no such variable";
  33. static char *isArray =        "variable is array";
  34. static char *needArray =    "variable isn't array";
  35. static char *noSuchElement =    "no such element in array";
  36. static char *traceActive =    "trace is active on variable";
  37.  
  38. #ifdef macintosh
  39. #    pragma segment tclVar
  40. #endif
  41.  
  42. /*
  43.  * Forward references to procedures defined later in this file:
  44.  */
  45.  
  46. static  char *        CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
  47.                 Tcl_HashEntry *hPtr, char *name1, char *name2,
  48.                 int flags));
  49. static void        DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
  50. static void        DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
  51.                 Var *varPtr, int flags));
  52. static Var *        NewVar _ANSI_ARGS_((int space));
  53. static ArraySearch *    ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
  54.                 Var *varPtr, char *varName, char *string));
  55. static void        VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
  56.                 char *name1, char *name2, char *operation,
  57.                 char *reason));
  58.  
  59. /*
  60.  *----------------------------------------------------------------------
  61.  *
  62.  * Tcl_GetVar --
  63.  *
  64.  *    Return the value of a Tcl variable.
  65.  *
  66.  * Results:
  67.  *    The return value points to the current value of varName.  If
  68.  *    the variable is not defined or can't be read because of a clash
  69.  *    in array usage then a NULL pointer is returned and an error
  70.  *    message is left in interp->result if the TCL_LEAVE_ERR_MSG
  71.  *    flag is set.  Note:  the return value is only valid up until
  72.  *    the next call to Tcl_SetVar or Tcl_SetVar2;  if you depend on
  73.  *    the value lasting longer than that, then make yourself a private
  74.  *    copy.
  75.  *
  76.  * Side effects:
  77.  *    None.
  78.  *
  79.  *----------------------------------------------------------------------
  80.  */
  81.  
  82. char *
  83. Tcl_GetVar(interp, varName, flags)
  84.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  85.                  * to be looked up. */
  86.     char *varName;        /* Name of a variable in interp. */
  87.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  88.                  * or TCL_LEAVE_ERR_MSG bits. */
  89. {
  90.     register char *p;
  91.  
  92.     /*
  93.      * If varName refers to an array (it ends with a parenthesized
  94.      * element name), then handle it specially.
  95.      */
  96.  
  97.     for (p = varName; *p != '\0'; p++) {
  98.     if (*p == '(') {
  99.         char *result;
  100.         char *open = p;
  101.  
  102.         do {
  103.         p++;
  104.         } while (*p != '\0');
  105.         p--;
  106.         if (*p != ')') {
  107.         goto scalar;
  108.         }
  109.         *open = '\0';
  110.         *p = '\0';
  111.         result = Tcl_GetVar2(interp, varName, open+1, flags);
  112.         *open = '(';
  113.         *p = ')';
  114.         return result;
  115.     }
  116.     }
  117.  
  118.     scalar:
  119.     return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
  120. }
  121.  
  122. /*
  123.  *----------------------------------------------------------------------
  124.  *
  125.  * Tcl_GetVar2 --
  126.  *
  127.  *    Return the value of a Tcl variable, given a two-part name
  128.  *    consisting of array name and element within array.
  129.  *
  130.  * Results:
  131.  *    The return value points to the current value of the variable
  132.  *    given by name1 and name2.  If the specified variable doesn't
  133.  *    exist, or if there is a clash in array usage, then NULL is
  134.  *    returned and a message will be left in interp->result if the
  135.  *    TCL_LEAVE_ERR_MSG flag is set.  Note:  the return value is
  136.  *    only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
  137.  *    if you depend on the value lasting longer than that, then make
  138.  *    yourself a private copy.
  139.  *
  140.  * Side effects:
  141.  *    None.
  142.  *
  143.  *----------------------------------------------------------------------
  144.  */
  145.  
  146. char *
  147. Tcl_GetVar2(interp, name1, name2, flags)
  148.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  149.                  * to be looked up. */
  150.     char *name1;        /* Name of array (if name2 is NULL) or
  151.                  * name of variable. */
  152.     char *name2;        /* If non-null, gives name of element in
  153.                  * array. */
  154.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  155.                  * or TCL_LEAVE_ERR_MSG bits. */
  156. {
  157.     Tcl_HashEntry *hPtr;
  158.     Var *varPtr;
  159.     Interp *iPtr = (Interp *) interp;
  160.     Var *arrayPtr = NULL;
  161.  
  162.     /*
  163.      * Lookup the first name.
  164.      */
  165.  
  166.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  167.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
  168.     } else {
  169.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
  170.     }
  171.     if (hPtr == NULL) {
  172.     if (flags & TCL_LEAVE_ERR_MSG) {
  173.         VarErrMsg(interp, name1, name2, "read", noSuchVar);
  174.     }
  175.     return NULL;
  176.     }
  177.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  178.     if (varPtr->flags & VAR_UPVAR) {
  179.     hPtr = varPtr->value.upvarPtr;
  180.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  181.     }
  182.  
  183.     /*
  184.      * If this is an array reference, then remember the traces on the array
  185.      * and lookup the element within the array.
  186.      */
  187.  
  188.     if (name2 != NULL) {
  189.     if (varPtr->flags & VAR_UNDEFINED) {
  190.         if (flags & TCL_LEAVE_ERR_MSG) {
  191.         VarErrMsg(interp, name1, name2, "read", noSuchVar);
  192.         }
  193.         return NULL;
  194.     } else if (!(varPtr->flags & VAR_ARRAY)) {
  195.         if (flags & TCL_LEAVE_ERR_MSG) {
  196.         VarErrMsg(interp, name1, name2, "read", needArray);
  197.         }
  198.         return NULL;
  199.     }
  200.     arrayPtr = varPtr;
  201.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
  202.     if (hPtr == NULL) {
  203.         if (flags & TCL_LEAVE_ERR_MSG) {
  204.         VarErrMsg(interp, name1, name2, "read", noSuchElement);
  205.         }
  206.         return NULL;
  207.     }
  208.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  209.     }
  210.  
  211.     /*
  212.      * Invoke any traces that have been set for the variable.
  213.      */
  214.  
  215.     if ((varPtr->tracePtr != NULL)
  216.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  217.     char *msg;
  218.  
  219.     msg = CallTraces(iPtr, arrayPtr, hPtr, name1, name2,
  220.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
  221.     if (msg != NULL) {
  222.         VarErrMsg(interp, name1, name2, "read", msg);
  223.         return NULL;
  224.     }
  225.  
  226.     /*
  227.      * Watch out!  The variable could have gotten re-allocated to
  228.      * a larger size.  Fortunately the hash table entry will still
  229.      * be around.
  230.      */
  231.  
  232.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  233.     }
  234.     if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY)) {
  235.     if (flags & TCL_LEAVE_ERR_MSG) {
  236.         VarErrMsg(interp, name1, name2, "read", noSuchVar);
  237.     }
  238.     return NULL;
  239.     }
  240.     return varPtr->value.string;
  241. }
  242.  
  243. /*
  244.  *----------------------------------------------------------------------
  245.  *
  246.  * Tcl_SetVar --
  247.  *
  248.  *    Change the value of a variable.
  249.  *
  250.  * Results:
  251.  *    Returns a pointer to the malloc'ed string holding the _new
  252.  *    value of the variable.  The caller should not modify this
  253.  *    string.  If the write operation was disallowed then NULL
  254.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  255.  *    an explanatory message will be left in interp->result.
  256.  *
  257.  * Side effects:
  258.  *    If varName is defined as a local or global variable in interp,
  259.  *    its value is changed to newValue.  If varName isn't currently
  260.  *    defined, then a _new global variable by that name is created.
  261.  *
  262.  *----------------------------------------------------------------------
  263.  */
  264.  
  265. char *
  266. Tcl_SetVar(interp, varName, newValue, flags)
  267.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  268.                  * to be looked up. */
  269.     char *varName;        /* Name of a variable in interp. */
  270.     char *newValue;        /* New value for varName. */
  271.     int flags;            /* Various flags that tell how to set value:
  272.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  273.                  * TCL_LIST_ELEMENT, TCL_NO_SPACE, or
  274.                  * TCL_LEAVE_ERR_MSG. */
  275. {
  276.     register char *p;
  277.  
  278.     /*
  279.      * If varName refers to an array (it ends with a parenthesized
  280.      * element name), then handle it specially.
  281.      */
  282.  
  283.     for (p = varName; *p != '\0'; p++) {
  284.     if (*p == '(') {
  285.         char *result;
  286.         char *open = p;
  287.  
  288.         do {
  289.         p++;
  290.         } while (*p != '\0');
  291.         p--;
  292.         if (*p != ')') {
  293.         goto scalar;
  294.         }
  295.         *open = '\0';
  296.         *p = '\0';
  297.         result = Tcl_SetVar2(interp, varName, open+1, newValue, flags);
  298.         *open = '(';
  299.         *p = ')';
  300.         return result;
  301.     }
  302.     }
  303.  
  304.     scalar:
  305.     return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
  306. }
  307.  
  308. /*
  309.  *----------------------------------------------------------------------
  310.  *
  311.  * Tcl_SetVar2 --
  312.  *
  313.  *    Given a two-part variable name, which may refer either to a
  314.  *    scalar variable or an element of an array, change the value
  315.  *    of the variable.  If the named scalar or array or element
  316.  *    doesn't exist then create one.
  317.  *
  318.  * Results:
  319.  *    Returns a pointer to the malloc'ed string holding the _new
  320.  *    value of the variable.  The caller should not modify this
  321.  *    string.  If the write operation was disallowed because an
  322.  *    array was expected but not found (or vice versa), then NULL
  323.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  324.  *    an explanatory message will be left in interp->result.
  325.  *
  326.  * Side effects:
  327.  *    The value of the given variable is set.  If either the array
  328.  *    or the entry didn't exist then a _new one is created.
  329.  *
  330.  *----------------------------------------------------------------------
  331.  */
  332.  
  333. char *
  334. Tcl_SetVar2(interp, name1, name2, newValue, flags)
  335.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  336.                  * to be looked up. */
  337.     char *name1;        /* If name2 is NULL, this is name of scalar
  338.                  * variable.  Otherwise it is name of array. */
  339.     char *name2;        /* Name of an element within array, or NULL. */
  340.     char *newValue;        /* New value for variable. */
  341.     int flags;            /* Various flags that tell how to set value:
  342.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  343.                  * TCL_LIST_ELEMENT, and TCL_NO_SPACE, or
  344.                  * TCL_LEAVE_ERR_MSG . */
  345. {
  346.     Tcl_HashEntry *hPtr;
  347.     Var *varPtr = NULL;
  348.                 /* Initial value only used to stop compiler
  349.                  * from complaining; not really needed. */
  350.     Interp *iPtr = (Interp *) interp;
  351.     int length, _new, listFlags;
  352.     Var *arrayPtr = NULL;
  353.  
  354. /*dprintf("Tcl_SetVar2: interp x%lx name1 '%.32s' name2 '%.32s' ", interp, name1, name2);*/
  355.     /*
  356.      * Lookup the first name.
  357.      */
  358.  
  359.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  360.         hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, name1, &_new);
  361.         }
  362.     else {
  363.         hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
  364.                                     name1, &_new);
  365.         }
  366.     
  367.     if (!_new) {
  368.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  369.         if (varPtr->flags & VAR_UPVAR) {
  370.             hPtr = varPtr->value.upvarPtr;
  371.             varPtr = (Var *) Tcl_GetHashValue(hPtr);
  372.             }
  373.         }
  374.  
  375.     /*
  376.      * If this is an array reference, then create a _new array (if
  377.      * needed), remember any traces on the array, and lookup the
  378.      * element within the array.
  379.      */
  380.  
  381.     if (name2 != NULL) {
  382.         if (_new) {
  383.             varPtr = NewVar(0);
  384.             Tcl_SetHashValue(hPtr, varPtr);
  385.             varPtr->flags = VAR_ARRAY;
  386.             varPtr->value.tablePtr = (Tcl_HashTable *)
  387.                 ckalloc(sizeof(Tcl_HashTable));
  388.             Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  389.             }
  390.         else {
  391.             if (varPtr->flags & VAR_UNDEFINED) {
  392.                 varPtr->flags = VAR_ARRAY;
  393.                 varPtr->value.tablePtr = (Tcl_HashTable *)
  394.                     ckalloc(sizeof(Tcl_HashTable));
  395.                 Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  396.                 }
  397.             else if (!(varPtr->flags & VAR_ARRAY)) {
  398.                 if (flags & TCL_LEAVE_ERR_MSG) {
  399.                     VarErrMsg(interp, name1, name2, "set", needArray);
  400.                     }
  401.                 return NULL;
  402.                 }
  403.             arrayPtr = varPtr;
  404.             }
  405.         
  406.         hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, name2, &_new);
  407.         }
  408.  
  409.     /*
  410.      * Compute how many bytes will be needed for newValue (leave space
  411.      * for a separating space between list elements).
  412.      */
  413.  
  414.     if (flags & TCL_LIST_ELEMENT) {
  415.         length = Tcl_ScanElement(newValue, &listFlags) + 1;
  416.         }
  417.     else {
  418.         length = strlen(newValue);
  419.         }
  420.  
  421.     /*
  422.      * If the variable doesn't exist then create a _new one.  If it
  423.      * does exist then clear its current value unless this is an
  424.      * append operation.
  425.      */
  426.  
  427.     if (_new) {
  428.         varPtr = NewVar(length);
  429.         Tcl_SetHashValue(hPtr, varPtr);
  430.         if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
  431.             DeleteSearches(arrayPtr);
  432.             }
  433.         }
  434.     else {
  435.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  436.         if (varPtr->flags & VAR_ARRAY) {
  437.             if (flags & TCL_LEAVE_ERR_MSG) {
  438.                 VarErrMsg(interp, name1, name2, "set", isArray);
  439.                 }
  440.             return NULL;
  441.             }
  442.         if (!(flags & TCL_APPEND_VALUE)) {
  443.             varPtr->valueLength = 0;
  444.             }
  445.         }
  446.  
  447.     /*
  448.      * Make sure there's enough space to hold the variable's
  449.      * _new value.  If not, enlarge the variable's space.
  450.      */
  451.  
  452.     if ((length + varPtr->valueLength) >= varPtr->valueSpace) {
  453.         Var *newVarPtr;
  454.         int newSize;
  455.     
  456.         newSize = 2*varPtr->valueSpace;
  457.         if (newSize <= (length + varPtr->valueLength)) {
  458.             newSize += length;
  459.             }
  460.         newVarPtr = NewVar(newSize);
  461.         newVarPtr->valueLength = varPtr->valueLength;
  462.         newVarPtr->upvarUses = varPtr->upvarUses;
  463.         newVarPtr->tracePtr = varPtr->tracePtr;
  464.         strcpy(newVarPtr->value.string, varPtr->value.string);
  465.         Tcl_SetHashValue(hPtr, newVarPtr);
  466.         ckfree((char *) varPtr);
  467.         varPtr = newVarPtr;
  468.         }
  469.  
  470.     /*
  471.      * Append the _new value to the variable, either as a list
  472.      * element or as a string.
  473.      */
  474.  
  475.     if (flags & TCL_LIST_ELEMENT) {
  476.         if ((varPtr->valueLength > 0) && !(flags & TCL_NO_SPACE)) {
  477.             varPtr->value.string[varPtr->valueLength] = ' ';
  478.             varPtr->valueLength++;
  479.         }
  480.         varPtr->valueLength += Tcl_ConvertElement(newValue,
  481.             varPtr->value.string + varPtr->valueLength, listFlags);
  482.         varPtr->value.string[varPtr->valueLength] = 0;
  483.         }
  484.     else {
  485.         strcpy(varPtr->value.string + varPtr->valueLength, newValue);
  486.         varPtr->valueLength += length;
  487.         }
  488.     varPtr->flags &= ~VAR_UNDEFINED;
  489.  
  490.     /*
  491.      * Invoke any write traces for the variable.
  492.      */
  493.  
  494.     if ((varPtr->tracePtr != NULL)
  495.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))
  496.         {
  497.         char *msg;
  498.     
  499.         msg = CallTraces(iPtr, arrayPtr, hPtr, name1, name2,
  500.             (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES);
  501.         if (msg != NULL) {
  502.             VarErrMsg(interp, name1, name2, "set", msg);
  503.             return NULL;
  504.             }
  505.     
  506.         /*
  507.          * Watch out!  The variable could have gotten re-allocated to
  508.          * a larger size.  Fortunately the hash table entry will still
  509.          * be around.
  510.          */
  511.     
  512.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  513.         }
  514.     return varPtr->value.string;
  515.     }
  516.  
  517.  
  518. /*
  519.  *----------------------------------------------------------------------
  520.  *
  521.  * Tcl_UnsetVar --
  522.  *
  523.  *    Delete a variable, so that it may not be accessed anymore.
  524.  *
  525.  * Results:
  526.  *    Returns 0 if the variable was successfully deleted, -1
  527.  *    if the variable can't be unset.  In the event of an error,
  528.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  529.  *    is left in interp->result.
  530.  *
  531.  * Side effects:
  532.  *    If varName is defined as a local or global variable in interp,
  533.  *    it is deleted.
  534.  *
  535.  *----------------------------------------------------------------------
  536.  */
  537.  
  538. int
  539. Tcl_UnsetVar(interp, varName, flags)
  540.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  541.                  * to be looked up. */
  542.     char *varName;        /* Name of a variable in interp.  May be
  543.                  * either a scalar name or an array name
  544.                  * or an element in an array. */
  545.     int flags;            /* OR-ed combination of any of
  546.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  547. {
  548.     register char *p;
  549.     int result;
  550.  
  551.     /*
  552.      * Figure out whether this is an array reference, then call
  553.      * Tcl_UnsetVar2 to do all the real work.
  554.      */
  555.  
  556.     for (p = varName; *p != '\0'; p++) {
  557.     if (*p == '(') {
  558.         char *open = p;
  559.  
  560.         do {
  561.         p++;
  562.         } while (*p != '\0');
  563.         p--;
  564.         if (*p != ')') {
  565.         goto scalar;
  566.         }
  567.         *open = '\0';
  568.         *p = '\0';
  569.         result = Tcl_UnsetVar2(interp, varName, open+1, flags);
  570.         *open = '(';
  571.         *p = ')';
  572.         return result;
  573.     }
  574.     }
  575.  
  576.     scalar:
  577.     return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
  578. }
  579.  
  580. /*
  581.  *----------------------------------------------------------------------
  582.  *
  583.  * Tcl_UnsetVar2 --
  584.  *
  585.  *    Delete a variable, given a 2-part name.
  586.  *
  587.  * Results:
  588.  *    Returns 0 if the variable was successfully deleted, -1
  589.  *    if the variable can't be unset.  In the event of an error,
  590.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  591.  *    is left in interp->result.
  592.  *
  593.  * Side effects:
  594.  *    If name1 and name2 indicate a local or global variable in interp,
  595.  *    it is deleted.  If name1 is an array name and name2 is NULL, then
  596.  *    the whole array is deleted.
  597.  *
  598.  *----------------------------------------------------------------------
  599.  */
  600.  
  601. int
  602. Tcl_UnsetVar2(interp, name1, name2, flags)
  603.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  604.                  * to be looked up. */
  605.     char *name1;        /* Name of variable or array. */
  606.     char *name2;        /* Name of element within array or NULL. */
  607.     int flags;            /* OR-ed combination of any of
  608.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  609. {
  610.     Tcl_HashEntry *hPtr, dummyEntry;
  611.     Var *varPtr, dummyVar;
  612.     Interp *iPtr = (Interp *) interp;
  613.     Var *arrayPtr = NULL;
  614.  
  615.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  616.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
  617.     } else {
  618.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
  619.     }
  620.     if (hPtr == NULL) {
  621.     if (flags & TCL_LEAVE_ERR_MSG) {
  622.         VarErrMsg(interp, name1, name2, "unset", noSuchVar);
  623.     }
  624.     return -1;
  625.     }
  626.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  627.  
  628.     /*
  629.      * For global variables referenced in procedures, leave the procedure's
  630.      * reference variable in place, but unset the global variable.  Can't
  631.      * decrement the actual variable's use count, since we didn't delete
  632.      * the reference variable.
  633.      */
  634.  
  635.     if (varPtr->flags & VAR_UPVAR) {
  636.     hPtr = varPtr->value.upvarPtr;
  637.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  638.     }
  639.  
  640.     /*
  641.      * If the variable being deleted is an element of an array, then
  642.      * remember trace procedures on the overall array and find the
  643.      * element to delete.
  644.      */
  645.  
  646.     if (name2 != NULL) {
  647.     if (!(varPtr->flags & VAR_ARRAY)) {
  648.         if (flags & TCL_LEAVE_ERR_MSG) {
  649.         VarErrMsg(interp, name1, name2, "unset", needArray);
  650.         }
  651.         return -1;
  652.     }
  653.     if (varPtr->searchPtr != NULL) {
  654.         DeleteSearches(varPtr);
  655.     }
  656.     arrayPtr = varPtr;
  657.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
  658.     if (hPtr == NULL) {
  659.         if (flags & TCL_LEAVE_ERR_MSG) {
  660.         VarErrMsg(interp, name1, name2, "unset", noSuchElement);
  661.         }
  662.         return -1;
  663.     }
  664.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  665.     }
  666.  
  667.     /*
  668.      * If there is a trace active on this variable or if the variable
  669.      * is already being deleted then don't delete the variable:  it
  670.      * isn't safe, since there are procedures higher up on the stack
  671.      * that will use pointers to the variable.  Also don't delete an
  672.      * array if there are traces active on any of its elements.
  673.      */
  674.  
  675.     if (varPtr->flags &
  676.         (VAR_TRACE_ACTIVE|VAR_ELEMENT_ACTIVE)) {
  677.     if (flags & TCL_LEAVE_ERR_MSG) {
  678.         VarErrMsg(interp, name1, name2, "unset", traceActive);
  679.     }
  680.     return -1;
  681.     }
  682.  
  683.     /*
  684.      * The code below is tricky, because of the possibility that
  685.      * a trace procedure might try to access a variable being
  686.      * deleted.  To handle this situation gracefully, copy the
  687.      * contents of the variable and its hash table entry to
  688.      * dummy variables, then clean up the actual variable so that
  689.      * it's been completely deleted before the traces are called.
  690.      * Then call the traces, and finally clean up the variable's
  691.      * storage using the dummy copies.
  692.      */
  693.  
  694.     dummyVar = *varPtr;
  695.     Tcl_SetHashValue(&dummyEntry, &dummyVar);
  696.     if (varPtr->upvarUses == 0) {
  697.     Tcl_DeleteHashEntry(hPtr);
  698.     ckfree((char *) varPtr);
  699.     } else {
  700.     varPtr->flags = VAR_UNDEFINED;
  701.     varPtr->tracePtr = NULL;
  702.     }
  703.  
  704.     /*
  705.      * Call trace procedures for the variable being deleted and delete
  706.      * its traces.
  707.      */
  708.  
  709.     if ((dummyVar.tracePtr != NULL)
  710.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  711.     (void) CallTraces(iPtr, arrayPtr, &dummyEntry, name1, name2,
  712.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  713.     while (dummyVar.tracePtr != NULL) {
  714.         VarTrace *tracePtr = dummyVar.tracePtr;
  715.         dummyVar.tracePtr = tracePtr->nextPtr;
  716.         ckfree((char *) tracePtr);
  717.     }
  718.     }
  719.  
  720.     /*
  721.      * If the variable is an array, delete all of its elements.  This
  722.      * must be done after calling the traces on the array, above (that's
  723.      * the way traces are defined).
  724.      */
  725.  
  726.     if (dummyVar.flags & VAR_ARRAY) {
  727.     DeleteArray(iPtr, name1, &dummyVar,
  728.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  729.     }
  730.     if (dummyVar.flags & VAR_UNDEFINED) {
  731.     if (flags & TCL_LEAVE_ERR_MSG) {
  732.         VarErrMsg(interp, name1, name2, "set", 
  733.             (name2 != NULL) ? noSuchVar : noSuchElement);
  734.     }
  735.     return -1;
  736.     }
  737.     return 0;
  738. }
  739.  
  740. /*
  741.  *----------------------------------------------------------------------
  742.  *
  743.  * Tcl_TraceVar --
  744.  *
  745.  *    Arrange for reads and/or writes to a variable to cause a
  746.  *    procedure to be invoked, which can monitor the operations
  747.  *    and/or change their actions.
  748.  *
  749.  * Results:
  750.  *    A standard Tcl return value.
  751.  *
  752.  * Side effects:
  753.  *    A trace is set up on the variable given by varName, such that
  754.  *    future references to the variable will be intermediated by
  755.  *    proc.  See the manual entry for complete details on the calling
  756.  *    sequence for proc.
  757.  *
  758.  *----------------------------------------------------------------------
  759.  */
  760.  
  761. int
  762. Tcl_TraceVar(interp, varName, flags, proc, clientData)
  763.     Tcl_Interp *interp;        /* Interpreter in which variable is
  764.                  * to be traced. */
  765.     char *varName;        /* Name of variable;  may end with "(index)"
  766.                  * to signify an array reference. */
  767.     int flags;            /* OR-ed collection of bits, including any
  768.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  769.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  770.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  771.                  * invoked upon varName. */
  772.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  773. {
  774.     register char *p;
  775.  
  776.     /*
  777.      * If varName refers to an array (it ends with a parenthesized
  778.      * element name), then handle it specially.
  779.      */
  780.  
  781.     for (p = varName; *p != '\0'; p++) {
  782.     if (*p == '(') {
  783.         int result;
  784.         char *open = p;
  785.  
  786.         do {
  787.         p++;
  788.         } while (*p != '\0');
  789.         p--;
  790.         if (*p != ')') {
  791.         goto scalar;
  792.         }
  793.         *open = '\0';
  794.         *p = '\0';
  795.         result = Tcl_TraceVar2(interp, varName, open+1, flags,
  796.             proc, clientData);
  797.         *open = '(';
  798.         *p = ')';
  799.         return result;
  800.     }
  801.     }
  802.  
  803.     scalar:
  804.     return Tcl_TraceVar2(interp, varName, (char *) NULL, flags,
  805.         proc, clientData);
  806. }
  807.  
  808. /*
  809.  *----------------------------------------------------------------------
  810.  *
  811.  * Tcl_TraceVar2 --
  812.  *
  813.  *    Arrange for reads and/or writes to a variable to cause a
  814.  *    procedure to be invoked, which can monitor the operations
  815.  *    and/or change their actions.
  816.  *
  817.  * Results:
  818.  *    A standard Tcl return value.
  819.  *
  820.  * Side effects:
  821.  *    A trace is set up on the variable given by name1 and name2, such
  822.  *    that future references to the variable will be intermediated by
  823.  *    proc.  See the manual entry for complete details on the calling
  824.  *    sequence for proc.
  825.  *
  826.  *----------------------------------------------------------------------
  827.  */
  828.  
  829. int
  830. Tcl_TraceVar2(interp, name1, name2, flags, proc, clientData)
  831.     Tcl_Interp *interp;        /* Interpreter in which variable is
  832.                  * to be traced. */
  833.     char *name1;        /* Name of scalar variable or array. */
  834.     char *name2;        /* Name of element within array;  NULL means
  835.                  * trace applies to scalar variable or array
  836.                  * as-a-whole. */
  837.     int flags;            /* OR-ed collection of bits, including any
  838.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  839.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  840.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  841.                  * invoked upon varName. */
  842.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  843. {
  844.     Tcl_HashEntry *hPtr;
  845.     Var *varPtr = NULL;        /* Initial value only used to stop compiler
  846.                  * from complaining; not really needed. */
  847.     Interp *iPtr = (Interp *) interp;
  848.     register VarTrace *tracePtr;
  849.     int _new;
  850.  
  851.     /*
  852.      * Locate the variable, making a _new (undefined) one if necessary.
  853.      */
  854.  
  855.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  856.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, name1, &_new);
  857.     } else {
  858.     hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, name1, &_new);
  859.     }
  860.     if (!_new) {
  861.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  862.     if (varPtr->flags & VAR_UPVAR) {
  863.         hPtr = varPtr->value.upvarPtr;
  864.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  865.     }
  866.     }
  867.  
  868.     /*
  869.      * If the trace is to be on an array element, make sure that the
  870.      * variable is an array variable.  If the variable doesn't exist
  871.      * then define it as an empty array.  Then find the specific
  872.      * array element.
  873.      */
  874.  
  875.     if (name2 != NULL) {
  876.     if (_new) {
  877.         varPtr = NewVar(0);
  878.         Tcl_SetHashValue(hPtr, varPtr);
  879.         varPtr->flags = VAR_ARRAY;
  880.         varPtr->value.tablePtr = (Tcl_HashTable *)
  881.             ckalloc(sizeof(Tcl_HashTable));
  882.         Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  883.     } else {
  884.         if (varPtr->flags & VAR_UNDEFINED) {
  885.         varPtr->flags = VAR_ARRAY;
  886.         varPtr->value.tablePtr = (Tcl_HashTable *)
  887.             ckalloc(sizeof(Tcl_HashTable));
  888.         Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  889.         } else if (!(varPtr->flags & VAR_ARRAY)) {
  890.         iPtr->result = needArray;
  891.         return TCL_ERROR;
  892.         }
  893.     }
  894.     hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, name2, &_new);
  895.     }
  896.  
  897.     if (_new) {
  898.     if ((name2 != NULL) && (varPtr->searchPtr != NULL)) {
  899.         DeleteSearches(varPtr);
  900.     }
  901.     varPtr = NewVar(0);
  902.     varPtr->flags = VAR_UNDEFINED;
  903.     Tcl_SetHashValue(hPtr, varPtr);
  904.     } else {
  905.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  906.     }
  907.  
  908.     /*
  909.      * Set up trace information.
  910.      */
  911.  
  912.     tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
  913.     tracePtr->traceProc = proc;
  914.     tracePtr->clientData = clientData;
  915.     tracePtr->flags = flags &
  916.         (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS);
  917.     tracePtr->nextPtr = varPtr->tracePtr;
  918.     varPtr->tracePtr = tracePtr;
  919.     return TCL_OK;
  920. }
  921.  
  922. /*
  923.  *----------------------------------------------------------------------
  924.  *
  925.  * Tcl_UntraceVar --
  926.  *
  927.  *    Remove a previously-created trace for a variable.
  928.  *
  929.  * Results:
  930.  *    None.
  931.  *
  932.  * Side effects:
  933.  *    If there exists a trace for the variable given by varName
  934.  *    with the given flags, proc, and clientData, then that trace
  935.  *    is removed.
  936.  *
  937.  *----------------------------------------------------------------------
  938.  */
  939.  
  940. void
  941. Tcl_UntraceVar(interp, varName, flags, proc, clientData)
  942.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  943.     char *varName;        /* Name of variable;  may end with "(index)"
  944.                  * to signify an array reference. */
  945.     int flags;            /* OR-ed collection of bits describing
  946.                  * current trace, including any of
  947.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  948.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  949.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  950.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  951. {
  952.     register char *p;
  953.  
  954.     /*
  955.      * If varName refers to an array (it ends with a parenthesized
  956.      * element name), then handle it specially.
  957.      */
  958.  
  959.     for (p = varName; *p != '\0'; p++) {
  960.     if (*p == '(') {
  961.         char *open = p;
  962.  
  963.         do {
  964.         p++;
  965.         } while (*p != '\0');
  966.         p--;
  967.         if (*p != ')') {
  968.         goto scalar;
  969.         }
  970.         *open = '\0';
  971.         *p = '\0';
  972.         Tcl_UntraceVar2(interp, varName, open+1, flags, proc, clientData);
  973.         *open = '(';
  974.         *p = ')';
  975.         return;
  976.     }
  977.     }
  978.  
  979.     scalar:
  980.     Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
  981. }
  982.  
  983. /*
  984.  *----------------------------------------------------------------------
  985.  *
  986.  * Tcl_UntraceVar2 --
  987.  *
  988.  *    Remove a previously-created trace for a variable.
  989.  *
  990.  * Results:
  991.  *    None.
  992.  *
  993.  * Side effects:
  994.  *    If there exists a trace for the variable given by name1
  995.  *    and name2 with the given flags, proc, and clientData, then
  996.  *    that trace is removed.
  997.  *
  998.  *----------------------------------------------------------------------
  999.  */
  1000.  
  1001. void
  1002. Tcl_UntraceVar2(interp, name1, name2, flags, proc, clientData)
  1003.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  1004.     char *name1;        /* Name of variable or array. */
  1005.     char *name2;        /* Name of element within array;  NULL means
  1006.                  * trace applies to scalar variable or array
  1007.                  * as-a-whole. */
  1008.     int flags;            /* OR-ed collection of bits describing
  1009.                  * current trace, including any of
  1010.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  1011.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  1012.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1013.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  1014. {
  1015.     register VarTrace *tracePtr;
  1016.     VarTrace *prevPtr;
  1017.     Var *varPtr;
  1018.     Interp *iPtr = (Interp *) interp;
  1019.     Tcl_HashEntry *hPtr;
  1020.     ActiveVarTrace *activePtr;
  1021.  
  1022.     /*
  1023.      * First, lookup the variable.
  1024.      */
  1025.  
  1026.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  1027.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
  1028.     } else {
  1029.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
  1030.     }
  1031.     if (hPtr == NULL) {
  1032.     return;
  1033.     }
  1034.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1035.     if (varPtr->flags & VAR_UPVAR) {
  1036.     hPtr = varPtr->value.upvarPtr;
  1037.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1038.     }
  1039.     if (name2 != NULL) {
  1040.     if (!(varPtr->flags & VAR_ARRAY)) {
  1041.         return;
  1042.     }
  1043.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
  1044.     if (hPtr == NULL) {
  1045.         return;
  1046.     }
  1047.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1048.     }
  1049.  
  1050.     flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
  1051.     for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
  1052.         prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
  1053.     if (tracePtr == NULL) {
  1054.         return;
  1055.     }
  1056.     if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
  1057.         && (tracePtr->clientData == clientData)) {
  1058.         break;
  1059.     }
  1060.     }
  1061.  
  1062.     /*
  1063.      * The code below makes it possible to delete traces while traces
  1064.      * are active:  it makes sure that the deleted trace won't be
  1065.      * processed by CallTraces.
  1066.      */
  1067.  
  1068.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  1069.         activePtr = activePtr->nextPtr) {
  1070.     if (activePtr->nextTracePtr == tracePtr) {
  1071.         activePtr->nextTracePtr = tracePtr->nextPtr;
  1072.     }
  1073.     }
  1074.     if (prevPtr == NULL) {
  1075.     varPtr->tracePtr = tracePtr->nextPtr;
  1076.     } else {
  1077.     prevPtr->nextPtr = tracePtr->nextPtr;
  1078.     }
  1079.     ckfree((char *) tracePtr);
  1080. }
  1081.  
  1082. /*
  1083.  *----------------------------------------------------------------------
  1084.  *
  1085.  * Tcl_VarTraceInfo --
  1086.  *
  1087.  *    Return the clientData value associated with a trace on a
  1088.  *    variable.  This procedure can also be used to step through
  1089.  *    all of the traces on a particular variable that have the
  1090.  *    same trace procedure.
  1091.  *
  1092.  * Results:
  1093.  *    The return value is the clientData value associated with
  1094.  *    a trace on the given variable.  Information will only be
  1095.  *    returned for a trace with proc as trace procedure.  If
  1096.  *    the clientData argument is NULL then the first such trace is
  1097.  *    returned;  otherwise, the next relevant one after the one
  1098.  *    given by clientData will be returned.  If the variable
  1099.  *    doesn't exist, or if there are no (more) traces for it,
  1100.  *    then NULL is returned.
  1101.  *
  1102.  * Side effects:
  1103.  *    None.
  1104.  *
  1105.  *----------------------------------------------------------------------
  1106.  */
  1107.  
  1108. ClientData
  1109. Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
  1110.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1111.     char *varName;        /* Name of variable;  may end with "(index)"
  1112.                  * to signify an array reference. */
  1113.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1114.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1115.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1116.                  * by this procedure, so this call will
  1117.                  * return the next trace after that one.
  1118.                  * If NULL, this call will return the
  1119.                  * first trace. */
  1120. {
  1121.     register char *p;
  1122.  
  1123.     /*
  1124.      * If varName refers to an array (it ends with a parenthesized
  1125.      * element name), then handle it specially.
  1126.      */
  1127.  
  1128.     for (p = varName; *p != '\0'; p++) {
  1129.     if (*p == '(') {
  1130.         ClientData result;
  1131.         char *open = p;
  1132.  
  1133.         do {
  1134.         p++;
  1135.         } while (*p != '\0');
  1136.         p--;
  1137.         if (*p != ')') {
  1138.         goto scalar;
  1139.         }
  1140.         *open = '\0';
  1141.         *p = '\0';
  1142.         result = Tcl_VarTraceInfo2(interp, varName, open+1, flags, proc,
  1143.         prevClientData);
  1144.         *open = '(';
  1145.         *p = ')';
  1146.         return result;
  1147.     }
  1148.     }
  1149.  
  1150.     scalar:
  1151.     return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc,
  1152.         prevClientData);
  1153. }
  1154.  
  1155. /*
  1156.  *----------------------------------------------------------------------
  1157.  *
  1158.  * Tcl_VarTraceInfo2 --
  1159.  *
  1160.  *    Same as Tcl_VarTraceInfo, except takes name in two pieces
  1161.  *    instead of one.
  1162.  *
  1163.  * Results:
  1164.  *    Same as Tcl_VarTraceInfo.
  1165.  *
  1166.  * Side effects:
  1167.  *    None.
  1168.  *
  1169.  *----------------------------------------------------------------------
  1170.  */
  1171.  
  1172. ClientData
  1173. Tcl_VarTraceInfo2(interp, name1, name2, flags, proc, prevClientData)
  1174.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1175.     char *name1;        /* Name of variable or array. */
  1176.     char *name2;        /* Name of element within array;  NULL means
  1177.                  * trace applies to scalar variable or array
  1178.                  * as-a-whole. */
  1179.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1180.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1181.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1182.                  * by this procedure, so this call will
  1183.                  * return the next trace after that one.
  1184.                  * If NULL, this call will return the
  1185.                  * first trace. */
  1186. {
  1187.     register VarTrace *tracePtr;
  1188.     Var *varPtr;
  1189.     Interp *iPtr = (Interp *) interp;
  1190.     Tcl_HashEntry *hPtr;
  1191.  
  1192.     /*
  1193.      * First, lookup the variable.
  1194.      */
  1195.  
  1196.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  1197.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
  1198.     } else {
  1199.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
  1200.     }
  1201.     if (hPtr == NULL) {
  1202.     return NULL;
  1203.     }
  1204.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1205.     if (varPtr->flags & VAR_UPVAR) {
  1206.     hPtr = varPtr->value.upvarPtr;
  1207.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1208.     }
  1209.     if (name2 != NULL) {
  1210.     if (!(varPtr->flags & VAR_ARRAY)) {
  1211.         return NULL;
  1212.     }
  1213.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
  1214.     if (hPtr == NULL) {
  1215.         return NULL;
  1216.     }
  1217.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1218.     }
  1219.  
  1220.     /*
  1221.      * Find the relevant trace, if any, and return its clientData.
  1222.      */
  1223.  
  1224.     tracePtr = varPtr->tracePtr;
  1225.     if (prevClientData != NULL) {
  1226.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1227.         if ((tracePtr->clientData == prevClientData)
  1228.             && (tracePtr->traceProc == proc)) {
  1229.         tracePtr = tracePtr->nextPtr;
  1230.         break;
  1231.         }
  1232.     }
  1233.     }
  1234.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1235.     if (tracePtr->traceProc == proc) {
  1236.         return tracePtr->clientData;
  1237.     }
  1238.     }
  1239.     return NULL;
  1240. }
  1241.  
  1242. /*
  1243.  *----------------------------------------------------------------------
  1244.  *
  1245.  * Tcl_SetCmd --
  1246.  *
  1247.  *    This procedure is invoked to process the "set" Tcl command.
  1248.  *    See the user documentation for details on what it does.
  1249.  *
  1250.  * Results:
  1251.  *    A standard Tcl result value.
  1252.  *
  1253.  * Side effects:
  1254.  *    A variable's value may be changed.
  1255.  *
  1256.  *----------------------------------------------------------------------
  1257.  */
  1258.  
  1259.     /* ARGSUSED */
  1260. int
  1261. Tcl_SetCmd(dummy, interp, argc, argv)
  1262.     ClientData dummy;            /* Not used. */
  1263.     register Tcl_Interp *interp;    /* Current interpreter. */
  1264.     int argc;                /* Number of arguments. */
  1265.     char **argv;            /* Argument strings. */
  1266. {
  1267.     if (argc == 2) {
  1268.     char *value;
  1269.  
  1270.     value = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  1271.     if (value == NULL) {
  1272.         return TCL_ERROR;
  1273.     }
  1274.     interp->result = value;
  1275.     return TCL_OK;
  1276.     } else if (argc == 3) {
  1277.     char *result;
  1278.  
  1279.     result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG);
  1280.     if (result == NULL) {
  1281.         return TCL_ERROR;
  1282.     }
  1283.     interp->result = result;
  1284.     return TCL_OK;
  1285.     } else {
  1286.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1287.         argv[0], " varName ?newValue?\"", (char *) NULL);
  1288.     return TCL_ERROR;
  1289.     }
  1290. }
  1291.  
  1292. /*
  1293.  *----------------------------------------------------------------------
  1294.  *
  1295.  * Tcl_UnsetCmd --
  1296.  *
  1297.  *    This procedure is invoked to process the "unset" Tcl command.
  1298.  *    See the user documentation for details on what it does.
  1299.  *
  1300.  * Results:
  1301.  *    A standard Tcl result value.
  1302.  *
  1303.  * Side effects:
  1304.  *    See the user documentation.
  1305.  *
  1306.  *----------------------------------------------------------------------
  1307.  */
  1308.  
  1309.     /* ARGSUSED */
  1310. int
  1311. Tcl_UnsetCmd(dummy, interp, argc, argv)
  1312.     ClientData dummy;            /* Not used. */
  1313.     register Tcl_Interp *interp;    /* Current interpreter. */
  1314.     int argc;                /* Number of arguments. */
  1315.     char **argv;            /* Argument strings. */
  1316. {
  1317.     int i;
  1318.  
  1319.     if (argc < 2) {
  1320.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1321.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1322.     return TCL_ERROR;
  1323.     }
  1324.     for (i = 1; i < argc; i++) {
  1325.     if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != 0) {
  1326.         return TCL_ERROR;
  1327.     }
  1328.     }
  1329.     return TCL_OK;
  1330. }
  1331.  
  1332. /*
  1333.  *----------------------------------------------------------------------
  1334.  *
  1335.  * Tcl_AppendCmd --
  1336.  *
  1337.  *    This procedure is invoked to process the "append" Tcl command.
  1338.  *    See the user documentation for details on what it does.
  1339.  *
  1340.  * Results:
  1341.  *    A standard Tcl result value.
  1342.  *
  1343.  * Side effects:
  1344.  *    A variable's value may be changed.
  1345.  *
  1346.  *----------------------------------------------------------------------
  1347.  */
  1348.  
  1349.     /* ARGSUSED */
  1350. int
  1351. Tcl_AppendCmd(dummy, interp, argc, argv)
  1352.     ClientData dummy;            /* Not used. */
  1353.     register Tcl_Interp *interp;    /* Current interpreter. */
  1354.     int argc;                /* Number of arguments. */
  1355.     char **argv;            /* Argument strings. */
  1356. {
  1357.     int i;
  1358.     char *result = NULL;        /* (Initialization only needed to keep
  1359.                      * the compiler from complaining) */
  1360.  
  1361.     if (argc < 3) {
  1362.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1363.         argv[0], " varName value ?value ...?\"", (char *) NULL);
  1364.     return TCL_ERROR;
  1365.     }
  1366.  
  1367.     for (i = 2; i < argc; i++) {
  1368.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1369.         TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
  1370.     if (result == NULL) {
  1371.         return TCL_ERROR;
  1372.     }
  1373.     }
  1374.     interp->result = result;
  1375.     return TCL_OK;
  1376. }
  1377.  
  1378. /*
  1379.  *----------------------------------------------------------------------
  1380.  *
  1381.  * Tcl_LappendCmd --
  1382.  *
  1383.  *    This procedure is invoked to process the "lappend" Tcl command.
  1384.  *    See the user documentation for details on what it does.
  1385.  *
  1386.  * Results:
  1387.  *    A standard Tcl result value.
  1388.  *
  1389.  * Side effects:
  1390.  *    A variable's value may be changed.
  1391.  *
  1392.  *----------------------------------------------------------------------
  1393.  */
  1394.  
  1395.     /* ARGSUSED */
  1396. int
  1397. Tcl_LappendCmd(dummy, interp, argc, argv)
  1398.     ClientData dummy;            /* Not used. */
  1399.     register Tcl_Interp *interp;    /* Current interpreter. */
  1400.     int argc;                /* Number of arguments. */
  1401.     char **argv;            /* Argument strings. */
  1402. {
  1403.     int i;
  1404.     char *result = NULL;        /* (Initialization only needed to keep
  1405.                      * the compiler from complaining) */
  1406.  
  1407.     if (argc < 3) {
  1408.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1409.         argv[0], " varName value ?value ...?\"", (char *) NULL);
  1410.     return TCL_ERROR;
  1411.     }
  1412.  
  1413.     for (i = 2; i < argc; i++) {
  1414.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1415.         TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG);
  1416.     if (result == NULL) {
  1417.         return TCL_ERROR;
  1418.     }
  1419.     }
  1420.     interp->result = result;
  1421.     return TCL_OK;
  1422. }
  1423.  
  1424. /*
  1425.  *----------------------------------------------------------------------
  1426.  *
  1427.  * Tcl_ArrayCmd --
  1428.  *
  1429.  *    This procedure is invoked to process the "array" Tcl command.
  1430.  *    See the user documentation for details on what it does.
  1431.  *
  1432.  * Results:
  1433.  *    A standard Tcl result value.
  1434.  *
  1435.  * Side effects:
  1436.  *    See the user documentation.
  1437.  *
  1438.  *----------------------------------------------------------------------
  1439.  */
  1440.  
  1441.     /* ARGSUSED */
  1442. int
  1443. Tcl_ArrayCmd(dummy, interp, argc, argv)
  1444.     ClientData dummy;            /* Not used. */
  1445.     register Tcl_Interp *interp;    /* Current interpreter. */
  1446.     int argc;                /* Number of arguments. */
  1447.     char **argv;            /* Argument strings. */
  1448. {
  1449.     int length;
  1450.     char c;
  1451.     Var *varPtr;
  1452.     Tcl_HashEntry *hPtr;
  1453.     Interp *iPtr = (Interp *) interp;
  1454.  
  1455.     if (argc < 3) {
  1456.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1457.         argv[0], " option arrayName ?arg ...?\"", (char *) NULL);
  1458.     return TCL_ERROR;
  1459.     }
  1460.  
  1461.     /*
  1462.      * Locate the array variable (and it better be an array).
  1463.      */
  1464.  
  1465.     if (iPtr->varFramePtr == NULL) {
  1466.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  1467.     } else {
  1468.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  1469.     }
  1470.     if (hPtr == NULL) {
  1471.     notArray:
  1472.     Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
  1473.         (char *) NULL);
  1474.     return TCL_ERROR;
  1475.     }
  1476.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1477.     if (varPtr->flags & VAR_UPVAR) {
  1478.     varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
  1479.     }
  1480.     if (!(varPtr->flags & VAR_ARRAY)) {
  1481.     goto notArray;
  1482.     }
  1483.  
  1484.     /*
  1485.      * Dispatch based on the option.
  1486.      */
  1487.  
  1488.     c = argv[1][0];
  1489.     length = strlen(argv[1]);
  1490.     if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
  1491.     ArraySearch *searchPtr;
  1492.  
  1493.     if (argc != 4) {
  1494.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1495.             argv[0], " anymore arrayName searchId\"", (char *) NULL);
  1496.         return TCL_ERROR;
  1497.     }
  1498.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1499.     if (searchPtr == NULL) {
  1500.         return TCL_ERROR;
  1501.     }
  1502.     while (1) {
  1503.         Var *varPtr2;
  1504.  
  1505.         if (searchPtr->nextEntry != NULL) {
  1506.         varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
  1507.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1508.             break;
  1509.         }
  1510.         }
  1511.         searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
  1512.         if (searchPtr->nextEntry == NULL) {
  1513.         interp->result = "0";
  1514.         return TCL_OK;
  1515.         }
  1516.     }
  1517.     interp->result = "1";
  1518.     return TCL_OK;
  1519.     } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
  1520.     ArraySearch *searchPtr, *prevPtr;
  1521.  
  1522.     if (argc != 4) {
  1523.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1524.             argv[0], " donesearch arrayName searchId\"", (char *) NULL);
  1525.         return TCL_ERROR;
  1526.     }
  1527.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1528.     if (searchPtr == NULL) {
  1529.         return TCL_ERROR;
  1530.     }
  1531.     if (varPtr->searchPtr == searchPtr) {
  1532.         varPtr->searchPtr = searchPtr->nextPtr;
  1533.     } else {
  1534.         for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
  1535.         if (prevPtr->nextPtr == searchPtr) {
  1536.             prevPtr->nextPtr = searchPtr->nextPtr;
  1537.             break;
  1538.         }
  1539.         }
  1540.     }
  1541.     ckfree((char *) searchPtr);
  1542.     } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)
  1543.         && (length >= 2)) {
  1544.     Tcl_HashSearch search;
  1545.     Var *varPtr2;
  1546.  
  1547.     if (argc != 3) {
  1548.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1549.             argv[0], " names arrayName\"", (char *) NULL);
  1550.         return TCL_ERROR;
  1551.     }
  1552.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1553.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1554.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1555.         if (varPtr2->flags & VAR_UNDEFINED) {
  1556.         continue;
  1557.         }
  1558.         Tcl_AppendElement(interp,
  1559.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), 0);
  1560.     }
  1561.     } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)
  1562.         && (length >= 2)) {
  1563.     ArraySearch *searchPtr;
  1564.     Tcl_HashEntry *hPtr;
  1565.  
  1566.     if (argc != 4) {
  1567.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1568.             argv[0], " nextelement arrayName searchId\"",
  1569.             (char *) NULL);
  1570.         return TCL_ERROR;
  1571.     }
  1572.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1573.     if (searchPtr == NULL) {
  1574.         return TCL_ERROR;
  1575.     }
  1576.     while (1) {
  1577.         Var *varPtr2;
  1578.  
  1579.         hPtr = searchPtr->nextEntry;
  1580.         if (hPtr == NULL) {
  1581.         hPtr = Tcl_NextHashEntry(&searchPtr->search);
  1582.         if (hPtr == NULL) {
  1583.             return TCL_OK;
  1584.         }
  1585.         } else {
  1586.         searchPtr->nextEntry = NULL;
  1587.         }
  1588.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1589.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1590.         break;
  1591.         }
  1592.     }
  1593.     interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1594.     } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  1595.         && (length >= 2)) {
  1596.     Tcl_HashSearch search;
  1597.     Var *varPtr2;
  1598.     int size;
  1599.  
  1600.     if (argc != 3) {
  1601.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1602.             argv[0], " size arrayName\"", (char *) NULL);
  1603.         return TCL_ERROR;
  1604.     }
  1605.     size = 0;
  1606.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1607.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1608.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1609.         if (varPtr2->flags & VAR_UNDEFINED) {
  1610.         continue;
  1611.         }
  1612.         size++;
  1613.     }
  1614.     sprintf(interp->result, "%d", size);
  1615.     } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)
  1616.         && (length >= 2)) {
  1617.     ArraySearch *searchPtr;
  1618.  
  1619.     if (argc != 3) {
  1620.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1621.             argv[0], " startsearch arrayName\"", (char *) NULL);
  1622.         return TCL_ERROR;
  1623.     }
  1624.     searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
  1625.     if (varPtr->searchPtr == NULL) {
  1626.         searchPtr->id = 1;
  1627.         Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
  1628.     } else {
  1629.         char string[20];
  1630.  
  1631.         searchPtr->id = varPtr->searchPtr->id + 1;
  1632.         sprintf(string, "%d", searchPtr->id);
  1633.         Tcl_AppendResult(interp, "s-", string, "-", argv[2],
  1634.             (char *) NULL);
  1635.     }
  1636.     searchPtr->varPtr = varPtr;
  1637.     searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
  1638.         &searchPtr->search);
  1639.     searchPtr->nextPtr = varPtr->searchPtr;
  1640.     varPtr->searchPtr = searchPtr;
  1641.     } else {
  1642.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1643.         "\": should be anymore, donesearch, names, nextelement, ",
  1644.         "size, or startsearch", (char *) NULL);
  1645.     return TCL_ERROR;
  1646.     }
  1647.     return TCL_OK;
  1648. }
  1649.  
  1650. /*
  1651.  *----------------------------------------------------------------------
  1652.  *
  1653.  * Tcl_GlobalCmd --
  1654.  *
  1655.  *    This procedure is invoked to process the "global" Tcl command.
  1656.  *    See the user documentation for details on what it does.
  1657.  *
  1658.  * Results:
  1659.  *    A standard Tcl result value.
  1660.  *
  1661.  * Side effects:
  1662.  *    See the user documentation.
  1663.  *
  1664.  *----------------------------------------------------------------------
  1665.  */
  1666.  
  1667.     /* ARGSUSED */
  1668. int
  1669. Tcl_GlobalCmd(dummy, interp, argc, argv)
  1670.     ClientData dummy;            /* Not used. */
  1671.     Tcl_Interp *interp;            /* Current interpreter. */
  1672.     int argc;                /* Number of arguments. */
  1673.     char **argv;            /* Argument strings. */
  1674. {
  1675.     Var *varPtr, *gVarPtr;
  1676.     register Interp *iPtr = (Interp *) interp;
  1677.     Tcl_HashEntry *hPtr, *hPtr2;
  1678.     int _new;
  1679.  
  1680.     if (argc < 2) {
  1681.     Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
  1682.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1683.     return TCL_ERROR;
  1684.     }
  1685.     if (iPtr->varFramePtr == NULL) {
  1686.     return TCL_OK;
  1687.     }
  1688.  
  1689.     for (argc--, argv++; argc > 0; argc--, argv++) {
  1690.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, *argv, &_new);
  1691.     if (_new) {
  1692.         gVarPtr = NewVar(0);
  1693.         gVarPtr->flags |= VAR_UNDEFINED;
  1694.         Tcl_SetHashValue(hPtr, gVarPtr);
  1695.     } else {
  1696.         gVarPtr = (Var *) Tcl_GetHashValue(hPtr);
  1697.     }
  1698.     hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, *argv, &_new);
  1699.     if (!_new) {
  1700.         Var *varPtr;
  1701.         varPtr = (Var *) Tcl_GetHashValue(hPtr2);
  1702.         if (varPtr->flags & VAR_UPVAR) {
  1703.         continue;
  1704.         } else {
  1705.         Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", *argv,
  1706.             "\" already exists", (char *) NULL);
  1707.         return TCL_ERROR;
  1708.         }
  1709.     }
  1710.     varPtr = NewVar(0);
  1711.     varPtr->flags |= VAR_UPVAR;
  1712.     varPtr->value.upvarPtr = hPtr;
  1713.     gVarPtr->upvarUses++;
  1714.     Tcl_SetHashValue(hPtr2, varPtr);
  1715.     }
  1716.     return TCL_OK;
  1717. }
  1718.  
  1719. /*
  1720.  *----------------------------------------------------------------------
  1721.  *
  1722.  * Tcl_UpvarCmd --
  1723.  *
  1724.  *    This procedure is invoked to process the "upvar" Tcl command.
  1725.  *    See the user documentation for details on what it does.
  1726.  *
  1727.  * Results:
  1728.  *    A standard Tcl result value.
  1729.  *
  1730.  * Side effects:
  1731.  *    See the user documentation.
  1732.  *
  1733.  *----------------------------------------------------------------------
  1734.  */
  1735.  
  1736.     /* ARGSUSED */
  1737. int
  1738. Tcl_UpvarCmd(dummy, interp, argc, argv)
  1739.     ClientData dummy;            /* Not used. */
  1740.     Tcl_Interp *interp;            /* Current interpreter. */
  1741.     int argc;                /* Number of arguments. */
  1742.     char **argv;            /* Argument strings. */
  1743. {
  1744.     register Interp *iPtr = (Interp *) interp;
  1745.     int result;
  1746.     CallFrame *framePtr;
  1747.     Var *varPtr = NULL;
  1748.     Tcl_HashTable *upVarTablePtr;
  1749.     Tcl_HashEntry *hPtr, *hPtr2;
  1750.     int _new;
  1751.     Var *upVarPtr;
  1752.  
  1753.     if (argc < 3) {
  1754.     upvarSyntax:
  1755.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1756.         " ?level? otherVar localVar ?otherVar localVar ...?\"",
  1757.         (char *) NULL);
  1758.     return TCL_ERROR;
  1759.     }
  1760.  
  1761.     /*
  1762.      * Find the hash table containing the variable being referenced.
  1763.      */
  1764.  
  1765.     result = TclGetFrame(interp, argv[1], &framePtr);
  1766.     if (result == -1) {
  1767.     return TCL_ERROR;
  1768.     }
  1769.     argc -= result+1;
  1770.     argv += result+1;
  1771.     if (framePtr == NULL) {
  1772.     upVarTablePtr = &iPtr->globalTable;
  1773.     } else {
  1774.     upVarTablePtr = &framePtr->varTable;
  1775.     }
  1776.  
  1777.     if ((argc & 1) != 0) {
  1778.     goto upvarSyntax;
  1779.     }
  1780.  
  1781.     /*
  1782.      * Iterate over all the pairs of (local variable, other variable)
  1783.      * names.  For each pair, create a hash table entry in the upper
  1784.      * context (if the name wasn't there already), then associate it
  1785.      * with a _new local variable.
  1786.      */
  1787.  
  1788.     while (argc > 0) {
  1789.         hPtr = Tcl_CreateHashEntry(upVarTablePtr, argv[0], &_new);
  1790.         if (_new) {
  1791.             upVarPtr = NewVar(0);
  1792.             upVarPtr->flags |= VAR_UNDEFINED;
  1793.             Tcl_SetHashValue(hPtr, upVarPtr);
  1794.         } else {
  1795.             upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
  1796.         if (upVarPtr->flags & VAR_UPVAR) {
  1797.         hPtr = upVarPtr->value.upvarPtr;
  1798.         upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
  1799.         }
  1800.         }
  1801.  
  1802.         hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
  1803.                     argv[1], &_new);
  1804.         if (!_new) {
  1805.             Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", argv[1],
  1806.                 "\" already exists", (char *) NULL);
  1807.             return TCL_ERROR;
  1808.         }
  1809.         varPtr = NewVar(0);
  1810.         varPtr->flags |= VAR_UPVAR;
  1811.         varPtr->value.upvarPtr = hPtr;
  1812.         upVarPtr->upvarUses++;
  1813.         Tcl_SetHashValue(hPtr2, varPtr);
  1814.  
  1815.         argc -= 2;
  1816.         argv += 2;
  1817.     }
  1818.     return TCL_OK;
  1819. }
  1820.  
  1821. /*
  1822.  *----------------------------------------------------------------------
  1823.  *
  1824.  * TclDeleteVars --
  1825.  *
  1826.  *    This procedure is called to recycle all the storage space
  1827.  *    associated with a table of variables.  For this procedure
  1828.  *    to work correctly, it must not be possible for any of the
  1829.  *    variable in the table to be accessed from Tcl commands
  1830.  *    (e.g. from trace procedures).
  1831.  *
  1832.  * Results:
  1833.  *    None.
  1834.  *
  1835.  * Side effects:
  1836.  *    Variables are deleted and trace procedures are invoked, if
  1837.  *    any are declared.
  1838.  *
  1839.  *----------------------------------------------------------------------
  1840.  */
  1841.  
  1842. void
  1843. TclDeleteVars(iPtr, tablePtr)
  1844.     Interp *iPtr;        /* Interpreter to which variables belong. */
  1845.     Tcl_HashTable *tablePtr;    /* Hash table containing variables to
  1846.                  * delete. */
  1847. {
  1848.     Tcl_HashSearch search;
  1849.     Tcl_HashEntry *hPtr;
  1850.     register Var *varPtr;
  1851.     int flags, globalFlag;
  1852.  
  1853.     flags = TCL_TRACE_UNSETS;
  1854.     if (tablePtr == &iPtr->globalTable) {
  1855.     flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY;
  1856.     }
  1857.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
  1858.         hPtr = Tcl_NextHashEntry(&search)) {
  1859.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1860.  
  1861.     /*
  1862.      * For global/upvar variables referenced in procedures, free up the
  1863.      * local space and then decrement the reference count on the
  1864.      * variable referred to.  If there are no more references to the
  1865.      * global/upvar and it is undefined and has no traces set, then
  1866.      * follow on and delete the referenced variable too.
  1867.      */
  1868.  
  1869.     globalFlag = 0;
  1870.     if (varPtr->flags & VAR_UPVAR) {
  1871.         hPtr = varPtr->value.upvarPtr;
  1872.         ckfree((char *) varPtr);
  1873.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1874.         varPtr->upvarUses--;
  1875.         if ((varPtr->upvarUses != 0) || !(varPtr->flags & VAR_UNDEFINED)
  1876.             || (varPtr->tracePtr != NULL)) {
  1877.         continue;
  1878.         }
  1879.         globalFlag = TCL_GLOBAL_ONLY;
  1880.     }
  1881.  
  1882.     /*
  1883.      * Invoke traces on the variable that is being deleted, then
  1884.      * free up the variable's space (no need to free the hash entry
  1885.      * here, unless we're dealing with a global variable:  the
  1886.      * hash entries will be deleted automatically when the whole
  1887.      * table is deleted).
  1888.      */
  1889.  
  1890.     if (varPtr->tracePtr != NULL) {
  1891.         (void) CallTraces(iPtr, (Var *) NULL, hPtr,
  1892.             Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL,
  1893.             flags | globalFlag);
  1894.         while (varPtr->tracePtr != NULL) {
  1895.         VarTrace *tracePtr = varPtr->tracePtr;
  1896.         varPtr->tracePtr = tracePtr->nextPtr;
  1897.         ckfree((char *) tracePtr);
  1898.         }
  1899.     }
  1900.     if (varPtr->flags & VAR_ARRAY) {
  1901.         DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr,
  1902.             flags | globalFlag);
  1903.     }
  1904.     if (globalFlag) {
  1905.         Tcl_DeleteHashEntry(hPtr);
  1906.     }
  1907.     ckfree((char *) varPtr);
  1908.     }
  1909.     Tcl_DeleteHashTable(tablePtr);
  1910. }
  1911.  
  1912. /*
  1913.  *----------------------------------------------------------------------
  1914.  *
  1915.  * CallTraces --
  1916.  *
  1917.  *    This procedure is invoked to find and invoke relevant
  1918.  *    trace procedures associated with a particular operation on
  1919.  *    a variable.  This procedure invokes traces both on the
  1920.  *    variable and on its containing array (where relevant).
  1921.  *
  1922.  * Results:
  1923.  *    The return value is NULL if no trace procedures were invoked, or
  1924.  *    if all the invoked trace procedures returned successfully.
  1925.  *    The return value is non-zero if a trace procedure returned an
  1926.  *    error (in this case no more trace procedures were invoked after
  1927.  *    the error was returned).  In this case the return value is a
  1928.  *    pointer to a static string describing the error.
  1929.  *
  1930.  * Side effects:
  1931.  *    Almost anything can happen, depending on trace;  this procedure
  1932.  *    itself doesn't have any side effects.
  1933.  *
  1934.  *----------------------------------------------------------------------
  1935.  */
  1936.  
  1937. static char *
  1938. CallTraces(iPtr, arrayPtr, hPtr, name1, name2, flags)
  1939.     Interp *iPtr;            /* Interpreter containing variable. */
  1940.     register Var *arrayPtr;        /* Pointer to array variable that
  1941.                      * contains the variable, or NULL if
  1942.                      * the variable isn't an element of an
  1943.                      * array. */
  1944.     Tcl_HashEntry *hPtr;        /* Hash table entry corresponding to
  1945.                      * variable whose traces are to be
  1946.                      * invoked. */
  1947.     char *name1, *name2;        /* Variable's two-part name. */
  1948.     int flags;                /* Flags to pass to trace procedures:
  1949.                      * indicates what's happening to
  1950.                      * variable, plus other stuff like
  1951.                      * TCL_GLOBAL_ONLY and
  1952.                      * TCL_INTERP_DESTROYED. */
  1953. {
  1954.     Var *varPtr;
  1955.     register VarTrace *tracePtr;
  1956.     ActiveVarTrace active;
  1957.     char *result;
  1958.     int savedArrayFlags = 0;        /* (Initialization not needed except
  1959.                      * to prevent compiler warning) */
  1960.  
  1961.     /*
  1962.      * If there are already similar trace procedures active for the
  1963.      * variable, don't call them again.
  1964.      */
  1965.  
  1966.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1967.     if (varPtr->flags & VAR_TRACE_ACTIVE) {
  1968.     return NULL;
  1969.     }
  1970.     varPtr->flags |= VAR_TRACE_ACTIVE;
  1971.  
  1972.     /*
  1973.      * Invoke traces on the array containing the variable, if relevant.
  1974.      */
  1975.  
  1976.     result = NULL;
  1977.     active.nextPtr = iPtr->activeTracePtr;
  1978.     iPtr->activeTracePtr = &active;
  1979.     if (arrayPtr != NULL) {
  1980.     savedArrayFlags = arrayPtr->flags;
  1981.     arrayPtr->flags |= VAR_ELEMENT_ACTIVE;
  1982.     for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
  1983.         tracePtr = active.nextTracePtr) {
  1984.         active.nextTracePtr = tracePtr->nextPtr;
  1985.         if (!(tracePtr->flags & flags)) {
  1986.         continue;
  1987.         }
  1988.         result = (*tracePtr->traceProc)(tracePtr->clientData,
  1989.             (Tcl_Interp *) iPtr, name1, name2, flags);
  1990.         if (result != NULL) {
  1991.         if (flags & TCL_TRACE_UNSETS) {
  1992.             result = NULL;
  1993.         } else {
  1994.             goto done;
  1995.         }
  1996.         }
  1997.     }
  1998.     }
  1999.  
  2000.     /*
  2001.      * Invoke traces on the variable itself.
  2002.      */
  2003.  
  2004.     if (flags & TCL_TRACE_UNSETS) {
  2005.     flags |= TCL_TRACE_DESTROYED;
  2006.     }
  2007.     for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
  2008.         tracePtr = active.nextTracePtr) {
  2009.     active.nextTracePtr = tracePtr->nextPtr;
  2010.     if (!(tracePtr->flags & flags)) {
  2011.         continue;
  2012.     }
  2013.     result = (*tracePtr->traceProc)(tracePtr->clientData,
  2014.         (Tcl_Interp *) iPtr, name1, name2, flags);
  2015.     if (result != NULL) {
  2016.         if (flags & TCL_TRACE_UNSETS) {
  2017.         result = NULL;
  2018.         } else {
  2019.         goto done;
  2020.         }
  2021.     }
  2022.     }
  2023.  
  2024.     /*
  2025.      * Restore the variable's flags, remove the record of our active
  2026.      * traces, and then return.  Remember that the variable could have
  2027.      * been re-allocated during the traces, but its hash entry won't
  2028.      * change.
  2029.      */
  2030.  
  2031.     done:
  2032.     if (arrayPtr != NULL) {
  2033.     arrayPtr->flags = savedArrayFlags;
  2034.     }
  2035.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  2036.     varPtr->flags &= ~VAR_TRACE_ACTIVE;
  2037.     iPtr->activeTracePtr = active.nextPtr;
  2038.     return result;
  2039. }
  2040.  
  2041. /*
  2042.  *----------------------------------------------------------------------
  2043.  *
  2044.  * NewVar --
  2045.  *
  2046.  *    Create a _new variable with a given initial value.
  2047.  *
  2048.  * Results:
  2049.  *    The return value is a pointer to the _new variable structure.
  2050.  *    The variable will not be part of any hash table yet, and its
  2051.  *    upvarUses count is initialized to 0.  Its initial value will
  2052.  *    be empty, but "space" bytes will be available in the value
  2053.  *    area.
  2054.  *
  2055.  * Side effects:
  2056.  *    Storage gets allocated.
  2057.  *
  2058.  *----------------------------------------------------------------------
  2059.  */
  2060.  
  2061. static Var *
  2062. NewVar(space)
  2063.     int space;        /* Minimum amount of space to allocate
  2064.              * for variable's value. */
  2065. {
  2066.     int extra;
  2067.     register Var *varPtr;
  2068.  
  2069.     extra = space - sizeof(varPtr->value);
  2070.     if (extra < 0) {
  2071.     extra = 0;
  2072.     space = sizeof(varPtr->value);
  2073.     }
  2074.     varPtr = (Var *) ckalloc((unsigned) (sizeof(Var) + extra));
  2075.     varPtr->valueLength = 0;
  2076.     varPtr->valueSpace = space;
  2077.     varPtr->upvarUses = 0;
  2078.     varPtr->tracePtr = NULL;
  2079.     varPtr->searchPtr = NULL;
  2080.     varPtr->flags = 0;
  2081.     varPtr->value.string[0] = 0;
  2082.     return varPtr;
  2083. }
  2084.  
  2085. /*
  2086.  *----------------------------------------------------------------------
  2087.  *
  2088.  * ParseSearchId --
  2089.  *
  2090.  *    This procedure translates from a string to a pointer to an
  2091.  *    active array search (if there is one that matches the string).
  2092.  *
  2093.  * Results:
  2094.  *    The return value is a pointer to the array search indicated
  2095.  *    by string, or NULL if there isn't one.  If NULL is returned,
  2096.  *    interp->result contains an error message.
  2097.  *
  2098.  * Side effects:
  2099.  *    None.
  2100.  *
  2101.  *----------------------------------------------------------------------
  2102.  */
  2103.  
  2104. static ArraySearch *
  2105. ParseSearchId(interp, varPtr, varName, string)
  2106.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  2107.     Var *varPtr;        /* Array variable search is for. */
  2108.     char *varName;        /* Name of array variable that search is
  2109.                  * supposed to be for. */
  2110.     char *string;        /* String containing id of search.  Must have
  2111.                  * form "search-num-var" where "num" is a
  2112.                  * decimal number and "var" is a variable
  2113.                  * name. */
  2114. {
  2115.     char *end;
  2116.     int id;
  2117.     ArraySearch *searchPtr;
  2118.  
  2119.     /*
  2120.      * Parse the id into the three parts separated by dashes.
  2121.      */
  2122.  
  2123.     if ((string[0] != 's') || (string[1] != '-')) {
  2124.     syntax:
  2125.     Tcl_AppendResult(interp, "illegal search identifier \"", string,
  2126.         "\"", (char *) NULL);
  2127.     return NULL;
  2128.     }
  2129.     id = strtoul(string+2, &end, 10);
  2130.     if ((end == (string+2)) || (*end != '-')) {
  2131.     goto syntax;
  2132.     }
  2133.     if (strcmp(end+1, varName) != 0) {
  2134.     Tcl_AppendResult(interp, "search identifier \"", string,
  2135.         "\" isn't for variable \"", varName, "\"", (char *) NULL);
  2136.     return NULL;
  2137.     }
  2138.  
  2139.     /*
  2140.      * Search through the list of active searches on the interpreter
  2141.      * to see if the desired one exists.
  2142.      */
  2143.  
  2144.     for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
  2145.         searchPtr = searchPtr->nextPtr) {
  2146.     if (searchPtr->id == id) {
  2147.         return searchPtr;
  2148.     }
  2149.     }
  2150.     Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
  2151.         (char *) NULL);
  2152.     return NULL;
  2153. }
  2154.  
  2155. /*
  2156.  *----------------------------------------------------------------------
  2157.  *
  2158.  * DeleteSearches --
  2159.  *
  2160.  *    This procedure is called to free up all of the searches
  2161.  *    associated with an array variable.
  2162.  *
  2163.  * Results:
  2164.  *    None.
  2165.  *
  2166.  * Side effects:
  2167.  *    Memory is released to the storage allocator.
  2168.  *
  2169.  *----------------------------------------------------------------------
  2170.  */
  2171.  
  2172. static void
  2173. DeleteSearches(arrayVarPtr)
  2174.     register Var *arrayVarPtr;        /* Variable whose searches are
  2175.                      * to be deleted. */
  2176. {
  2177.     ArraySearch *searchPtr;
  2178.  
  2179.     while (arrayVarPtr->searchPtr != NULL) {
  2180.     searchPtr = arrayVarPtr->searchPtr;
  2181.     arrayVarPtr->searchPtr = searchPtr->nextPtr;
  2182.     ckfree((char *) searchPtr);
  2183.     }
  2184. }
  2185.  
  2186. /*
  2187.  *----------------------------------------------------------------------
  2188.  *
  2189.  * DeleteArray --
  2190.  *
  2191.  *    This procedure is called to free up everything in an array
  2192.  *    variable.  It's the caller's responsibility to make sure
  2193.  *    that the array is no longer accessible before this procedure
  2194.  *    is called.
  2195.  *
  2196.  * Results:
  2197.  *    None.
  2198.  *
  2199.  * Side effects:
  2200.  *    All storage associated with varPtr's array elements is deleted
  2201.  *    (including the hash table).  Any delete trace procedures for
  2202.  *    array elements are invoked.
  2203.  *
  2204.  *----------------------------------------------------------------------
  2205.  */
  2206.  
  2207. static void
  2208. DeleteArray(iPtr, arrayName, varPtr, flags)
  2209.     Interp *iPtr;            /* Interpreter containing array. */
  2210.     char *arrayName;            /* Name of array (used for trace
  2211.                      * callbacks). */
  2212.     Var *varPtr;            /* Pointer to variable structure. */
  2213.     int flags;                /* Flags to pass to CallTraces:
  2214.                      * TCL_TRACE_UNSETS and sometimes
  2215.                      * TCL_INTERP_DESTROYED and/or
  2216.                      * TCL_GLOBAL_ONLY. */
  2217. {
  2218.     Tcl_HashSearch search;
  2219.     register Tcl_HashEntry *hPtr;
  2220.     register Var *elPtr;
  2221.  
  2222.     DeleteSearches(varPtr);
  2223.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  2224.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  2225.     elPtr = (Var *) Tcl_GetHashValue(hPtr);
  2226.     if (elPtr->tracePtr != NULL) {
  2227.         (void) CallTraces(iPtr, (Var *) NULL, hPtr, arrayName,
  2228.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
  2229.         while (elPtr->tracePtr != NULL) {
  2230.         VarTrace *tracePtr = elPtr->tracePtr;
  2231.         elPtr->tracePtr = tracePtr->nextPtr;
  2232.         ckfree((char *) tracePtr);
  2233.         }
  2234.     }
  2235.     if (elPtr->flags & VAR_SEARCHES_POSSIBLE) {
  2236.         panic("DeleteArray found searches on array alement!");
  2237.     }
  2238.     ckfree((char *) elPtr);
  2239.     }
  2240.     Tcl_DeleteHashTable(varPtr->value.tablePtr);
  2241.     ckfree((char *) varPtr->value.tablePtr);
  2242. }
  2243.  
  2244. /*
  2245.  *----------------------------------------------------------------------
  2246.  *
  2247.  * VarErrMsg --
  2248.  *
  2249.  *    Generate a reasonable error message describing why a variable
  2250.  *    operation failed.
  2251.  *
  2252.  * Results:
  2253.  *    None.
  2254.  *
  2255.  * Side effects:
  2256.  *    Interp->result is reset to hold a message identifying the
  2257.  *    variable given by name1 and name2 and describing why the
  2258.  *    variable operation failed.
  2259.  *
  2260.  *----------------------------------------------------------------------
  2261.  */
  2262.  
  2263. static void
  2264. VarErrMsg(interp, name1, name2, operation, reason)
  2265. Tcl_Interp *interp;        /* Interpreter in which to record message. */
  2266. char *name1, *name2;    /* Variable's two-part name. */
  2267. char *operation;        /* String describing operation that failed,
  2268.              * e.g. "read", "set", or "unset". */
  2269. char *reason;        /* String describing why operation failed. */
  2270.     {
  2271.     Tcl_ResetResult(interp);
  2272.     Tcl_AppendResult(interp, "can't ", operation, " \"", name1, (char *) NULL);
  2273.     if (name2 != NULL) {
  2274.         Tcl_AppendResult(interp, "(", name2, ")", (char *) NULL);
  2275.         }
  2276.     Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
  2277.     }
  2278.